(declare (mapex t)
         (special **exp** **env** **unevlis** **evlis** **pc** **clink** **val** **tem**
                  **queue** **tick** **quantum** **process**
                  version lispversion))

(defun version macro (x)
       (cond (compiler-state (list 'quote (status uread)))
	     (t (rplaca x 'quote)
		(rplacd x (list version))
		(list 'quote version))))

(declare (read))

(setq version ((lambda (compiler-state) (version)) t))

(defun fastcall (atsym)
       (cond ((eq (car (cdr atsym)) 'subr)
	      (subrcall nil (cadr (cdr atsym))))
	     (t ((lambda (subr)
			 (cond (subr (remprop atsym 'subr)
				     (putprop atsym
					      subr
					      'subr)
				     (subrcall nil subr))
			       (t (apply atsym nil))))
		 (get atsym 'subr)))))

(defun fastcall3 (atsym arg1 arg2 arg3)
       (cond ((eq (car (cdr atsym)) 'subr)
	      (subrcall nil (cadr (cdr atsym)) arg1 arg2 arg3))
	     (t ((lambda (subr)
			 (cond (subr (remprop atsym 'subr)
				     (putprop atsym
					      subr
					      'subr)
				     (subrcall nil subr arg1 arg2 arg3))
			       (t (funcall atsym arg1 arg2 arg3))))
		 (get atsym 'subr)))))

(defun scheme ()
       (setq version (version)  lispversion (status lispversion))
       (terpri)
       (princ '|This is SCHEME |)
       (princ version)
       (princ '| running in LISP |)
       (princ lispversion)
       (setq **env** nil  **queue** nil
             **process** (create!process '(**top** '|SCHEME -- Toplevel| '|==> |)))
       (swapinprocess)
       (alarmclock 'runtime **quantum**)
       (mloop))

(setq **top**
      '(beta (lambda (**message** **prompt**)
                (labels ((**top1**
                          (lambda (**ignore1** **ignore2** **ignore3**)
                             (**top1** (terpri) (princ **prompt**)
                                       (print (set '* (evaluate (read))))))))
                    (**top1** (terpri) (princ **message**) nil)))
             nil))

(defun mloop ()
       (do ((**tick** nil))  (nil)
          (and **tick** (allow) (schedule))
          (fastcall **pc**)))

(defun allow ()
  ((lambda (vcell)
       (cond (vcell (car vcell))
             (t t)))
   (lookup '*allow* **env**)))

(defun schedule ()
       ((lambda (oldint)
                (cond (**queue**
                       (swapoutprocess)
                       (nconc **queue** (list **process**))
                       (setq **process** (car **queue**)
                             **queue** (cdr **queue**))
                       (swapinprocess)))
                (setq **tick** nil)
                (alarmclock 'runtime **quantum**)
                (nointerrupt oldint))
        (nointerrupt t)))

(defun swapoutprocess ()
       ((lambda (**clink**)
                (putprop **process** (saveup **pc**) 'clink)
                (putprop **process** **val** 'val))
        **clink**))

(defun swapinprocess () 
       (setq **clink** (get **process** 'clink)
             **val** (get **process** 'val))
       (restore))

(defun settick (x) (setq **tick** t))
(setq **quantum** 1000000. alarmclock 'settick)

(defprop evaluate aeval aint)

(defun aeval (exp1 env1 retag)
       (saveup retag) (setq **env** env1)
       (dispatch (cadr exp1) env1 'aeval1))

(defun aeval1 ()
       (setq **tem** **env**) (restore)
       (dispatch **val** **tem** **pc**))

(defun dispatch (exp1 env1 retag)
   (prog (tem1)
    lp (cond ((atom exp1)
              (cond ((numberp exp1)
                     (setq **val** exp1  **pc** retag))
                    ((primop exp1)
                     (setq **val** exp1  **pc** retag))
                    ((setq tem1 (lookup exp1 env1))
                     (setq **val** (car tem1)  **pc** retag))
                    (t (setq **val** (symeval exp1)  **pc** retag))))
             ((eq (car exp1) 'lambda)
              (setq **val** (list 'beta exp1 env1)  **pc** retag))
             ((atom (car exp1))
              (cond ((setq tem1 (get (car exp1) 'aint))
                     (fastcall3 tem1 exp1 env1 retag))
                    ((setq tem1 (get (car exp1) 'amacro))
                     (setq exp1 (funcall tem1 exp1))
                     (go lp))
                    (t (saveup retag)
                       (setq **evlis** (list (cond ((primop (car exp1)) (car exp1))
                                               ((setq tem1 (lookup (car exp1) env1))
                                                (car tem1))
                                               (t (symeval (car exp1)))))
                             **unevlis** (cdr exp1)
			     **exp** exp1
                             **env** env1
                             **pc** 'evlis1))))
             ((eq (caar exp1) 'lambda)
              (saveup retag)
              (setq **evlis** (list (car exp1))  **unevlis** (cdr exp1)
                    **exp** exp1  **env** env1
                    **pc** 'evlis1))
             (t (saveup retag)
                (setq **exp** exp1  **env** env1
                      **unevlis** exp1  **evlis** nil
                      **pc** 'evlis1)))))

(defun evlis1 ()
       (cond ((null **unevlis**)
              (prog (ev1 env1)
                    (setq ev1 (reverse **evlis**))
                    (cond ((atom (car ev1))
                           (restore)
                           (setq **val** (apply (car ev1) (cdr ev1))))
                          ((eq (caar ev1) 'lambda)
                           (setq env1 **env**)
                           (restore)
                           (dispatch (caddar ev1)
                                     (pairify (cadar ev1) (cdr ev1) env1)
                                     **pc**))
                          ((eq (caar ev1) 'beta)
                           (restore)
                           (dispatch (caddr (cadar ev1))
                                     (pairify (cadr (cadar ev1))
                                              (cdr ev1)
                                              (caddar ev1))
                                     **pc**))
                          ((eq (caar ev1) 'delta)
                           (setq **clink** (cadar ev1))
                           (restore))
                          (t (error '|Bad Function - Evarglist| **exp** 'fail-act)))))
             (t (dispatch (car **unevlis**) **env** 'evlis2))))

(defun evlis2 ()
 (setq **evlis** (cons **val** **evlis**)  **unevlis** (cdr **unevlis**)  **pc** 'evlis1))

(defprop if aif aint)

(defun aif (exp1 env1 retag)
       (saveup retag)
       (setq **exp** exp1  **env** env1)
       (dispatch (cadr exp1) env1 'if1))

(defun if1 ()
   (prog (exp1 env1)
       (setq exp1 **exp**  env1 **env**)
       (restore)
       (cond (**val** (dispatch (caddr exp1) env1 **pc**))
             (t (dispatch (cadddr exp1) env1 **pc**)))))

(defprop test atest aint)

(defun atest (exp1 env1 retag)
       (saveup retag)
       (setq **exp** exp1  **env** env1)
       (dispatch (cadr exp1) env1 'test1))

(defun test1 ()
       (cond (**val**
	      (setq **evlis** **val**)
	      (dispatch (caddr **exp**) **env** 'test2))
	     (t ((lambda (exp1 env1)
			 (restore)
			 (dispatch (cadddr exp1) env1 **pc**))
		 **exp** **env**))))

(defun test2 ()
       (setq **evlis** (list **evlis** **val**))
       (setq **unevlis** nil)
       (evlis1))

(defprop quote aquote aint)

(defun aquote (exp1 env1 retag)
       (setq **val** (cadr exp1)  **pc** retag))

(defprop labels alabels aint)

(defun alabels (exp1 env1 retag)
       (setq env1 (cons nil env1))
       (rplaca env1
	       (cons (mapcar 'car (cadr exp1))
		     (do ((x (cadr exp1) (cdr x))
			  (z nil (cons (list 'beta (cadar x) env1) z)))
			 ((null x) z))))
       (dispatch (caddr exp1) env1 retag))

(defprop define adefine aint)

(defun adefine (exp1 env1 retag)
       (set (cadr exp1) (list 'beta  (caddr exp1) nil))
       (setq **val** (cadr exp1)  **pc** retag))

(defprop aset aaset aint)

(defun aaset (exp1 env1 retag)
       (saveup retag)
       (setq **exp** exp1  **env** env1)
       (dispatch (cadr exp1) env1 'aaset1))

(defun aaset1 ()
       (setq **evlis** **val**)
       (dispatch (caddr **exp**) **env** 'aaset2))

(defun aaset2 ()
       (setq **tem** (lookup **evlis** **env**))
       (cond (**tem** (rplaca **tem** **val**))
             (t (set **evlis** **val**)))
       (restore))

(setq **procnum** 0)

(defun genprocname ()
       ((lambda (base)
		(implode (append '(p r o c e s s)
				  (exploden (setq **procnum** (1+ **procnum**))))))
	10.))

(defun create!process (exp1)
       ((lambda (**process** **exp** **env** **unevlis** **evlis** **pc** **clink** **val**)
                (dispatch exp1 **env** 'terminate)
                (swapoutprocess)
                **process**)
        (genprocname) nil **env** nil nil nil nil nil))

(defun start!process (p)
    (cond ((or (not (atom p)) (not (get p 'clink)))
           (error '|Bad process -- Start!process| p 'fail-act)))
    ((lambda (oldint) 
             (or (eq p **process**) (memq p **queue**)
                 (setq **queue** (nconc **queue** (list p))))
             (nointerrupt oldint))
     (nointerrupt t))
    p)

(defun stop!process (p)
    (cond ((memq p **queue**)
           ((lambda (oldint)
		    (setq **queue** (delete p **queue**))
		    (nointerrupt oldint))
	    (nointerrupt t)))
          ((eq p **process**) (terminate)))
    p)

(defun terminate ()
       ((lambda (oldint)
                (swapoutprocess)
                (cond ((null **queue**)
                       (setq **env** nil)
                       (setq **process**
                             (create!process '(**top** '|SCHEME -- Queueout| '|==> |))))
                      (t (setq **process** (car **queue**)
                               **queue** (cdr **queue**))))
                (swapinprocess)
                (nointerrupt oldint)
                'terminate-value)
        (nointerrupt t)))

(defprop evaluate!uninterruptibly evun aint)

(defun evun (exp1 env1 retag)
   (dispatch (cadr exp1) (pairify '(**allow**) (list nil) env1) retag))

(defprop catch acatch aint)

(defun acatch (exp1 env1 retag)
       (dispatch (caddr exp1)
		 (pairify (list (cadr exp1))
			  (list (list 'delta
				       ((lambda (**clink**) (saveup retag))
					**clink**)))
			  env1)
                 retag))

(defun lookup (var env)
       (do ((e env (cdr e)) (vcell nil)) ((null e) vcell)
          (do ((vlist (caar e) (cdr vlist)) (vals (cdar e) (cdr vals)))
              ((null vlist))
              (cond ((eq (car vlist) var) 
                     (setq vcell vals  e nil)
                     (return nil))))))

(defun pairify (x y z)
       (cond ((and *rset (not (= (length x) (length y))))
	      (error '|Wrong Number of Arguments|
		      **exp**
		      'wrng-no-args))
	     (t (cons (cons x y) z))))

(defun pairify1 (x y z)
       (cond ((and *rset (not (= (length x) (length (cdr y)))))
	      (error '|Wrong Number of Arguments|
		      **exp**
		      'wrng-no-args))
	     (t (cons (list x y) z))))

(defun primop (x) (getl x '(subr expr lsubr)))

(defun saveup (retag)
       (setq **clink** 
             (cons **exp**
                   (cons **env**
                         (cons **unevlis**
                               (cons **evlis**
                                     (cons retag **clink**)))))))

(defun restore ()
  (prog (ltem)
       (setq ltem (or **clink**
		     (error '|Process Ran Out - Restore|
			     **exp**
			     'fail-act))
             **exp** (car ltem)
              ltem (cdr ltem)
             **env** (car ltem)
              ltem (cdr ltem)
             **unevlis** (car ltem)
              ltem (cdr ltem)
             **evlis** (car ltem)
              ltem (cdr ltem)
             **pc** (car ltem)
             **clink** (cdr ltem))))
βββ